home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / tdial.arc / MENU.INC < prev    next >
Text File  |  1985-09-23  |  10KB  |  348 lines
  1. const
  2.   menu_max_ent  = 20;             { Maximum number of entries per menu   }
  3.                                   { May be modified as desired; if it is }
  4.                                   { made larger, the length of type SSTR }
  5.                                   { should be increased as well          }
  6. type
  7.   menu_str    = string[80];
  8.   menu_sstr   = string[20];
  9.  
  10.        { This is the description of one entry in a menu }
  11.   menu_entry = record
  12.          short_name  : menu_sstr;
  13.          description : menu_str;
  14.          return_val  : char;
  15.          start_pos   : integer;
  16.          end;
  17.  
  18.        { This is the complete description of a menu. The ENTRY array uses
  19.          dynamically allocated variables to reduce the amount of wasted
  20.          memory space. }
  21.   menu_list_type = record
  22.          xline1, yline1,
  23.          xline2, yline2,
  24.          blanks, entries
  25.                    : integer;
  26.          unique    : menu_sstr;
  27.          entry     : array[1..menu_max_ent] of ^menu_entry;
  28.          end;
  29.  
  30. procedure ReverseVid;
  31.  
  32.    begin
  33.       textcolor(tb5);
  34.       textbackground(tc5);
  35.    end;
  36.  
  37. procedure NormVid;
  38.  
  39.    begin
  40.       textcolor(tc5);
  41.       textbackground(tb5);
  42.    end;
  43.  
  44. procedure HighVid;
  45.  
  46.    begin
  47.       textcolor(fc5);
  48.       textbackground(tb5);
  49.    end;
  50.  
  51. procedure menu_init(var menu:menu_list_type; spacing,x1,y1,x2,y2:integer);
  52.  { Initialize a Menu }
  53. var x : integer;
  54. begin
  55.   with menu do begin
  56.     entries   := 0;
  57.     unique    := '';
  58.     xline1    := x1;
  59.     yline1    := y1;
  60.     xline2    := x2;
  61.     yline2    := y2;
  62.     blanks    := spacing;
  63.     for x := 1 to menu_max_ent do
  64.       entry[x] := nil;
  65.     end; (* with *)
  66. end; (* proc menu_init *)
  67.  
  68. procedure menu_clr(var menu:menu_list_type);
  69.  { Clear a menu after use
  70.    DO NOT use this on a menu before the menu has been initialized!! }
  71. var
  72.   x : integer;
  73. begin
  74.   with menu do begin
  75.     for x := 1 to entries do
  76.       if entry[x] <> nil then begin
  77.         dispose(entry[x]);
  78.         entry[x] := nil;
  79.         end;
  80.     entries := 0;
  81.     unique  := '';
  82.     end; (* with *)
  83. end; (* proc menu_clr *)
  84.  
  85. function menu_srch(menu:menu_list_type;
  86.                    srch:menu_sstr; srch_type:integer):integer;
  87.  { search a menu.
  88.    SRCH_TYPE = 1 means to search for the short name SRCH
  89.    SRCH_TYPE = 2 means to search for the return value SRCH[1]
  90.    SRCH_TYPE = 3 means to search for the first character of SRCH as the first
  91.                  character of SHORT_NAME
  92.    return the appropriatte subscript if SRCH is found, otherwise zero }
  93. var
  94.   x : integer;
  95. begin
  96.   x := 1;
  97.   with menu do begin
  98.     case srch_type of
  99.       1 : {search for srch=short_name[x]}
  100.           while ((x<=entries) and (srch<>entry[x]^.short_name)) do
  101.             x := x + 1;
  102.       2 : {search for srch=return_val[x]}
  103.           if srch = '' then
  104.             x := 0
  105.           else
  106.             while ((x<=entries) and (srch[1]<>entry[x]^.return_val)) do
  107.               x := x + 1;
  108.       3 : {search for srch[1]=short_name[x,1]}
  109.           while ((x<=entries) and
  110.                  (copy(srch,1,1)<>copy(entry[x]^.short_name,1,1))) do
  111.             x := x + 1;
  112.       else
  113.           x := 0;
  114.       end; (* case*)
  115.     if x > entries then
  116.       x := 0;
  117.     end; (* with *)
  118.     menu_srch := x;
  119. end; (* func menu_srch *)
  120.  
  121. procedure menu_add(var menu:menu_list_type;
  122.                    sname:menu_sstr; desc:menu_str; rtval:char);
  123.  { Add an entry to a menu.
  124.    If the menu already has the maximum allowable entries, issue a message
  125.    and halt the system.
  126.    Add 1 to the number of entries and move the short name, description,
  127.    and return value to the menu array. Set the START_POS for this entry
  128.    so that it will be seperated from its predecessor by the proper space }
  129. var
  130.   p : integer;
  131. begin
  132.   if menu.entries = menu_max_ent then begin
  133.     writeln;
  134.     writeln('attempt to add too many entries to menu');
  135.     writeln(sname,' / ',desc,' / ',rtval);
  136.     writeln('System Halting');
  137.     halt;
  138.     end;
  139.   while ((sname<>'') and (sname[1]=' ')) do
  140.     delete(sname,1,1);
  141.   if sname = '' then
  142.     sname := '***';
  143.   if rtval = ' ' then
  144.     rtval := copy(sname,1,1);
  145.   with menu do begin
  146.     p := pos(sname[1],unique);
  147.     if p > 0 then
  148.       insert(sname[1],unique,p)
  149.     else
  150.       unique := unique + sname[1];
  151.     entries := entries + 1;
  152.     new(entry[entries]);
  153.     with entry[entries]^ do begin
  154.       short_name   := sname;
  155.       description  := desc;
  156.       return_val   := rtval;
  157.       if entries = 1 then
  158.         start_pos := menu.xline1
  159.       else
  160.         start_pos := entry[entries-1]^.start_pos +
  161.                      length(entry[entries-1]^.short_name) +
  162.                      blanks;
  163.       end; (* with *)
  164.     end; (* with *)
  165. end; (* proc menu_add *)
  166.  
  167. procedure menu_finalize(var menu:menu_list_type);
  168.  { Finalize the format of a menu.
  169.    This procedure performs the following operations:
  170.       * make a list of the unique first characters of the short names
  171.       * if the short names will not fit on one line with the specified
  172.         spacing, shrink the spacing to make the menu fit
  173.       * if the short names can't be made to fit, issue a message and HALT. }
  174. label exit;
  175. var
  176.   line_length,
  177.   menu_length,
  178.   spacing,
  179.   x, y   : integer;
  180.  
  181.   procedure delete_dups(ch:char; var list:menu_sstr);
  182.   var
  183.     p : integer;
  184.   begin
  185.     p := pos(ch,list);
  186.     while p > 0 do begin
  187.       delete(list,p,1);
  188.       p := pos(ch,list);
  189.       end;
  190.   end; (* proc delete_dups *)
  191.  
  192. begin
  193.   with menu do begin
  194.     if entries < 2 then
  195.       goto exit;
  196.     x := 1;
  197.     while x < length(unique) do begin
  198.       y := x+1;
  199.       while y <= length(unique) do
  200.         if unique[x] = unique[y] then
  201.           delete_dups(unique[x], unique)
  202.         else
  203.           y := y + 1;
  204.       x := x + 1;
  205.       end;
  206.     line_length := 80 - xline1;
  207.     with entry[entries]^ do
  208.       if start_pos + length(short_name) <= line_length then
  209.         goto exit;
  210.     menu_length := 0;
  211.     for x := 1 to entries do
  212.       menu_length := menu_length + length(entry[x]^.short_name);
  213.     blanks := (line_length - menu_length) div entries;
  214.     if blanks < 1 then begin
  215.       writeln;
  216.       writeln('Menu short names are too long to fit on one line.');
  217.       for x := 1 to entries do
  218.         write(entry[x]^.short_name,' ');
  219.       writeln;
  220.       writeln('System Halting');
  221.       halt;
  222.       end
  223.     else
  224.       for x := 2 to entries do
  225.         entry[x]^.start_pos := entry[x-1]^.start_pos +
  226.                                length(entry[x-1]^.short_name) + blanks;
  227.     end; (* with *)
  228. exit:
  229. end; (* proc menu_finalize *)
  230.  
  231. function menu_exec(menu:menu_list_type; current:integer):char;
  232. { This is the procedure which actually displays and processes the menu.
  233.   The argument CURRENT is an integer which specifies which entry should
  234.   be high-lighted at the start (the default). }
  235. const
  236.   home_key = #199;
  237.   end_key  = #207;
  238.   left     = #203;
  239.   right    = #205;
  240.   return   = #13;
  241.   tab      = #9;
  242.   back_tab = #143;
  243.   pg_up    = #201;
  244.   pg_dn    = #209;
  245.   escape   = #27;
  246. var
  247.   ch   : char;
  248.   x,
  249.   new  : integer;
  250.  
  251.   procedure menu_write(x,y:integer; marked:boolean; s:menu_sstr);
  252.   var
  253.     savex,
  254.     savey : integer;
  255.   begin
  256.     savex := wherex;
  257.     savey := wherey;
  258.     gotoxy(x,y);
  259.     if marked then begin
  260.       ReverseVid;
  261.       write(s);
  262.       HighVid;
  263.       end
  264.     else begin
  265.       HighVid;
  266.       write(s);
  267.       end;
  268.     gotoxy(savex,savey);
  269.   end; (* proc menu_write *)
  270.  
  271. begin
  272.   HighVid;
  273.   if current < 1 then
  274.     current := 1;
  275.   if current > menu.entries then
  276.     current := menu.entries;
  277.   gotoxy(menu.xline2, menu.yline2); clreol;
  278.   gotoxy(menu.xline1, menu.yline1); clreol;
  279.   for x := 1 to menu.entries do
  280.     with menu.entry[x]^ do begin
  281.       gotoxy(start_pos,menu.yline1);
  282.       write(short_name);
  283.       end;
  284.   repeat
  285.     with menu.entry[current]^ do begin
  286.       menu_write(start_pos,menu.yline1,true,short_name);
  287.       gotoxy(menu.xline2, menu.yline2); clreol;
  288.       NormVid;
  289.       write(description);
  290.       repeat
  291.         read(kbd,ch);
  292.         if keypressed then begin
  293.           read(kbd,ch);
  294.           if ord(ch) < 128 then
  295.             ch := chr(ord(ch)+128);
  296.           end;
  297.       until pos(ch,return+left+tab+right+back_tab+home_key+pg_up+end_key+pg_dn
  298.                    +escape+menu.unique) > 0;
  299.       if pos(ch,menu.unique)>0 then begin
  300.         gotoxy(wherex-1,wherey);
  301.         write(' ');
  302.         new := menu_srch(menu,ch+'',3);
  303.         current := new;
  304.         gotoxy(menu.xline2, menu.yline2); clreol;
  305.         write(menu.entry[current]^.description);
  306.         ch := return;
  307.         end;
  308.       menu_write(start_pos, menu.yline1, false, short_name);
  309.       end; (* with *)
  310.     case ch of
  311.       pg_up,
  312.       home_key : current := 1;
  313.       pg_dn,
  314.       end_key  : current := menu.entries;
  315.       back_tab,
  316.       left     : current := current - 1;
  317.       tab,
  318.       right    : current := current + 1;
  319.       escape   : begin
  320.                  menu_exec := ' ';
  321.                  ch := return;
  322.                  end;
  323.       return   : menu_exec := menu.entry[current]^.return_val;
  324.       else;
  325.       end; (* case *)
  326.     if current < 1 then
  327.       current := menu.entries
  328.     else
  329.     if current > menu.entries then
  330.       current := 1;
  331.   until ch = return;
  332.   NormVid;
  333. end; (* func menu_exec *)
  334.  
  335. procedure EraseMenu;
  336.  
  337.    var
  338.       i  :  integer;
  339.  
  340.    begin
  341.       for i := 1 to 2 do
  342.          begin
  343.             gotoxy(1,i);
  344.             clreol;
  345.          end;
  346.       gotoxy(1,1);
  347.       NormVid;
  348.    end;